(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open XNum
open UniTools
open UTypes
open Logging
open Dim
open Substitute
open FontMetric

type ('box, 'cmd) glyph_composer = (font_metric, 'box, 'cmd) Substitute.glyph_composer (* with sexp_of *)
type ('box, 'cmd) simple_glyph_item = (font_metric, 'box, 'cmd) glyph_item (* with sexp_of *)
type ('box, 'cmd) extended_glyph_item = (font_metric * (('box, 'cmd) glyph_composer), 'box, 'cmd) glyph_item (* with sexp_of *)

(* debugging aids *)

let dump_item i =
  match i with
    | `Char c -> log_uc_list [ c ]
    | `Glyph ((g, f)) ->
        begin
          match get_unicode f g with
            | [|  |] -> log_string "?"
            | str -> log_uc_string str
        end
    | `Kern _ -> log_string "¸"
    | `Command _ -> log_string "!"
    | `Box _ -> log_string "[]"
    | `Break _ -> log_string "|"
        
let dump_item_list items =
  (log_string ">"; List.iter dump_item items; log_string "<\n")
    
let dump_item_array items =
  (log_string ">"; Array.iter dump_item items; log_string "<\n")

(*-----------------------------------------------------------------------*)
(* auxiliary functions *)

(* |convert_to_glyphs <font> <items>| replaces all |`Char| items in
   <items> by the corresponding |`Glyph| item. *)
let rec convert_to_glyph font composer item =
  match item with
    | `Char c ->
        let text = GlyphText (UniText.of_ints [|c|]) in
          `Glyph (FontMetric.get_glyph font c, (font, composer), text)

    | `Break (p, h, pre, post, no) ->
        `Break
          (p, h,
           convert_to_glyphs font composer pre,
           convert_to_glyphs font composer post,
           convert_to_glyphs font composer no)

    | `Kern _ as i -> i
    | `Command _ as i -> i
    | `Box _ as i -> i

and convert_to_glyphs font composer items =
  let new_items =
    Array.make (List.length items) (`Glyph (Undef, (font, composer), NoGlyphText))
  in
  let rec iter k items =
    match items with
      | [] -> new_items
      | i :: is ->
          new_items.(k) <- convert_to_glyph font composer i;
          iter (k + 1) is
  in
    iter 0 items

(*-----------------------------------------------------------------------*)
(* hyphenation *)

type hyphen_params = {
  hyphenate : Hyphenation.hyphenator;
  hyphen_penalty : num;
  ex_hyphen_penalty : num;
  left_hyphen_min : int;
  right_hyphen_min : int;
  script_lang : uc_string
} (* with sexp_of *)

(*
  |convert_to_glyphs_and_add_breaks <hyphen-params> <font> <items>| replaces
  all |`Character| items in <items> by the corresponding |`Glyph| item.
  It also performs hyphenation and inserts break points.
  The return value is a pair (<new-items>, <break-pos>) consisting of the obtained
  array of items and an array with the positions of all break points. The latter
  one is deliminated entries with value -1 and <length-of-new-items>.
*)
let rec convert_to_glyphs_and_add_breaks hyphen_params font composer items =
  (* Collects all characters in <items> and returns them in an array.
     The boundary -1 is added as first and last element. *)
  let rec collect_characters n chars items =
    match items with
      | [] ->
          let word = Array.make (n + 2) (-1) in
          let _ = List.fold_left (fun i c -> (word.(i) <- c; i - 1)) n chars in
            word
      | `Char c :: is -> collect_characters (n + 1) (c :: chars) is
      | _ :: is -> collect_characters n chars is in
  let hg = get_hyphen_glyph font in
  let word = collect_characters 0 [] items in
  let breaks = (hyphen_params.hyphenate
                  ~left_min:hyphen_params.left_hyphen_min
                  ~right_min:hyphen_params.right_hyphen_min
                  ~word:word)
  in
  let new_items = ListBuilder.make () in
  let rec iter k items =
    match items with
      | [] -> ListBuilder.get new_items
      | i :: is ->
          match i with
            | `Char c ->
                let text = GlyphText (UniText.of_ints [|c|]) in
                let glyph = `Glyph (((get_glyph font c), (font, composer), text)) in
                  ListBuilder.add new_items glyph;
                  if breaks.(k) then
                    (* A hyphenation break should be represented as a
                       Unicode soft-hyphen. See PDF Reference 1.7,
                       page 888. *)
                    let discretionary_hyphen_text = GlyphText (UniText.of_ints [|0x00AD|]) in
                      ListBuilder.add new_items
                        begin
                          `Break
                            begin
                              hyphen_params.hyphen_penalty,
                              true,
                              [| `Glyph (hg, (font, composer), discretionary_hyphen_text) |],
                              [| |],
                              [| |]
                            end
                        end
                  else
                    ();
                  iter (k + 1) is
            | `Break (p, h, pre, post, no) ->
                ListBuilder.add new_items
                  (`Break (p, h,
                           convert_to_glyphs font composer pre,
                           convert_to_glyphs font composer post,
                           convert_to_glyphs font composer no));
                iter k is
            | `Kern _ as i ->
                ListBuilder.add new_items i;
                iter k is
            | `Command _ as i ->
                ListBuilder.add new_items i;
                iter k is
            | `Box _ as i ->
                ListBuilder.add new_items i;
                iter k is
  in
    iter 2 items

(*-----------------------------------------------------------------------*)      
(* high-level interfaces to add ligatures and kerning *)

let rec strip_composer item =
  match item with
    | `Glyph (g, (f, _), t) -> `Glyph (g, f, t)
    | `Break (p, h, pre, post, no) ->
        `Break
          (p, h,
           (Array.map strip_composer pre),
           (Array.map strip_composer post),
           (Array.map strip_composer no))
    | `Box _ as i -> i
    | `Command _ as i -> i
    | `Kern _ as i -> i
  
(* |find_word_list <builder> <keep-breaks> <composer> <items>| adds the prefix of <items>
   to <builder> until a glyph with a different composer is encountered. It returns the remaining
   items and the number of items moved. *)
let rec find_word_list builder keep_breaks composer items =
  let rec iter n items =
    match items with
      | [] -> ([], n)
      | i :: is ->
          match i with
            | `Glyph (g, (f, c), t) ->
                if c == composer then (* We assume that |c == composer| implies |f == font|. *)
                  begin
                    ListBuilder.add builder (`Glyph (g, f, t));
                    iter (n + 1) is
                  end
                else
                  (items, n)
            | `Command _ as i ->
                ListBuilder.add builder i;
                iter (n + 1) is
            | `Kern _ as i -> 
                ListBuilder.add builder i;
                iter (n + 1) is
            | `Break _ ->
                if keep_breaks then
                  ListBuilder.add builder (strip_composer i);
                iter (n + 1) is
            | `Box _ -> (items, n)
  in
    iter 1 items
  
(* |find_word_array <builder> <keep-breaks> <composer> <form> <to> <items>| is the array version
   of |find_word_list|. It returns the starting position of the remaining items. *)
let rec find_word_array builder keep_breaks composer from_pos to_pos items =
  if from_pos > to_pos then
    from_pos
  else
    let i = items.(from_pos) in
      match i with
        | `Glyph (g, (f, c), t) ->
            if c == composer then
              begin
                ListBuilder.add builder (`Glyph (g, f, t));
                find_word_array builder keep_breaks composer (from_pos + 1)
                  to_pos items
              end
            else
              from_pos
        | `Command _ as i ->
            ListBuilder.add builder i;
            find_word_array builder keep_breaks composer (from_pos + 1)
              to_pos items
        | `Kern _ as i ->
            ListBuilder.add builder i;
            find_word_array builder keep_breaks composer (from_pos + 1)
              to_pos items
        | `Break _ ->
            if keep_breaks then
              ListBuilder.add builder (strip_composer i);
            find_word_array builder keep_breaks composer (from_pos + 1)
              to_pos items
        | `Box _ -> from_pos
  
let rec add_lig_kern ~keep_breaks items =
  let word = ListBuilder.make () in
  let result = ListBuilder.make () in
  let rec iter items =
    match items with
      | [] -> ListBuilder.get result
      | i :: is ->
          match i with
            | `Glyph ((g, (f, composer), t)) ->
                ListBuilder.add word (`Glyph (g, f, t));
                let (rest, _) = find_word_list word keep_breaks composer is in
                  ListBuilder.add_list result (composer (ListBuilder.get word));
                  iter rest
            | _ ->
                ListBuilder.add result (strip_composer i);
                iter is
  in
    iter items
  
let add_lig_kern_iterative_list ~keep_breaks prefix items =
  let word = ListBuilder.make () in
  let rec iter prefix len items =
    match items with
      | [] -> (prefix, len, [])
      | i :: is ->
          begin
            match i with
              | `Glyph (g, (f, composer), t) ->
                  begin
                    ListBuilder.add word (`Glyph (g, f, t));
                    let (rest, n) = find_word_list word keep_breaks composer is in
                      match rest with
                        | [] -> (prefix, len, items)
                        | _ -> iter (List.rev_append (composer (ListBuilder.get word)) prefix) (len + n) rest
                  end
              | _ -> iter ((strip_composer i) :: prefix) (len + 1) is
          end
  in
    iter prefix 0 items
  
let add_lig_kern_iterative_array ~keep_breaks prefix from_pos to_pos items =
  let word = ListBuilder.make () in
  let rec iter prefix current_pos =
    if current_pos > to_pos then
      (prefix, current_pos)
    else
      let i = items.(current_pos) in
        match i with
          | `Glyph ((g, (f, composer), t)) ->
              ListBuilder.add word (`Glyph ((g, f, t)));
              let pos = find_word_array word keep_breaks composer (current_pos + 1) to_pos items in
                if pos > to_pos then
                  (prefix, current_pos)
                else
                  iter (List.rev_append (composer (ListBuilder.get word)) prefix) pos
          | _ -> iter ((strip_composer i) :: prefix) (current_pos + 1)
  in
    iter prefix from_pos
  
(* |add_lig_kern_finish <prefix> <from> <to> <items>| processes those items
   left over by |add_lig_kern_iterative|. In particular, it assume that <from>
   is the value returned by |add_lig_kern_iterative|, that is, the item at
   position <from> is a glyph and the items between <from> and <to> form a
   single word. *)
let add_lig_kern_finish prefix from_pos to_pos items =
  let rec get_word list to_pos =
    if from_pos > to_pos then
      list
    else
      get_word ((strip_composer items.(to_pos)) :: list) (to_pos - 1)
  in
    if from_pos > to_pos then
      prefix
    else
      match items.(from_pos) with
        | `Glyph (_, (_, composer), _) ->
            List.rev_append (composer (get_word [] to_pos)) prefix
        | _ -> assert false

(*-----------------------------------------------------------------------*)      

let empty_hyphen_params =
  { hyphenate = Hyphenation.null_hyphenator;
    hyphen_penalty = num_zero;
    ex_hyphen_penalty = num_zero;
    left_hyphen_min = 0;
    right_hyphen_min = 0;
    script_lang = [| |] }

(*-----------------------------------------------------------------------*)      
